;; Little Ludwig
;; Genetic algorithm music generator

(defconstant *population-size* 100) 
(defconstant *selection-size* 8)
(defconstant *pc-m* 50)
(defconstant *pc-c* 40)
(defconstant *pc-x* 60)

;;; INPUT

(setf twinkle '(
  C5q C5q G5q G5q A5q A5q G5h
  F5q F5q E5q E5q D5q D5q C5h
  G5q G5q F5q F5q E5q E5q D5h
  G5q G5q F5q F5q E5q E5q D5h
  C5q C5q G5q G5q A5q A5q G5h
  F5q F5q E5q E5q D5q D5q C5h
 )
)

(setf canon '(
  D5h E5h A5h Bb5h C#5h Rq A5q A5q Ab5h
  G5q G5q F#5h F5q F5q E5q Eb5q D5q
  C#5q A3q D5q G5q F5h E5h D5h F5h A5i G5i A5i
  D6i A5i F5i E5i F5i G5i A5i B5i C#6i D6i F5i
  G5i A5i Bb5i E5i F5i G5i A5i G5i F5i E5i F5i
  G5i A5i Bb5i C6i Bb5i A5i G5i A5i Bb5i C6i D6i
  Eb6i C6i Bb5i A5i B5i C#6i D6i E6i F6i D6i
  C#6i B5i C#6i D6i E6i F6i G6i E6i A5i E6i D6i
  E6i F6i G6i F6i E6i D6i C#6i D6q A5q F5q D5q
 )
)

(setf entertainer '(
  D5q D#5q E5q C6h E5q C6h E5q C6q- C6-w Rq C6q D6q D#6q E6q C6q D6q E6q- E6-q B5q D6h C6w Rh
  D5q D#5q E5q C6h E5q C6h E5q C6q- C6-w Rh A5q G5q F#5q A5q C6q E6q- E6-q D6q C6q A5q D6w Rh
  D5q D#5q E5q C6h E5q C6h E5q C6q- C6-w Rq C6q D6q D#6q E6q C6q D6q E6q- E6-q B5q D6h C6w Rh
  C6q D6q E6q C6q D6q E6q- E6-q C6q D6q C6q E6q C6q D6q E6q- E6-q C6q D6q C6q E6q C6q D6q E6q- E6-q B5q D6h C6w
 )
)

(setf suffocation '(
B4i. B5s B5h. C6q B5h. C6q B5h. C6q B5h. Bb5q A5h. B5q A5h. B5q A5h. B5i. A5s A5h. G#5h A5i
B5i D6i C6i E5i A5s F#5h. A5q F#5h B5i A5q G5i F#5i C5i B4i Eb5i F#5i D6i* C6i* B5i* B5h. C6q
B5h. C6q B5h. C6q B5i. Bb5s Bb5q A6q F#6i. E6s E6i Eb6i C7i Eb6i Eb6i E6i G6i B5i D6i C6i E6i*
E5i* A5i* F#5q A5i F#5h B5i A5q F#5h. E5s E5h. F#5q E5h. F#5q E5h
 )
)

(setf *input* suffocation)

;;; NOTES

(defmethod random-notes ()
  (append (list (first *input*)) (notes (- (length *input*) 2)) (last *input*))
)

(defmethod random-note ()
  (pick (remove-duplicates *input*))
)

(setf *random-note* #'random-note)

(defmethod notes ((n number)) 
  (if (> n 0) (cons (funcall *random-note*) (notes (- n 1))))
)

;;; NOTE MUTATION

(defmethod mutation ((notes list)) 
  (change notes (funcall *random-note*) (+ 1 (random (- (length notes) 2)))) 
)

(defmethod change ((l list) s (n number))
  (if (= n 0)
    (cons s (cdr l))
    (cons (car l) (change (cdr l) s (- n 1)))
 )
)
 
(defmethod pick ((l list)) 
  (nth (random (length l)) l) 
) 

;;; NOTE CROSSOVER

(defmethod crossover ((m list) (f list) &aux pos) 
  (setf pos (+ 1 (random (length m)))) 
  (append (first-n m pos) (rest-n f pos)) 
) 

(defmethod first-n ((l list) (n number))  
  (cond ((= n 0) ()) 
        (t       (cons (first l) (first-n (cdr l) (- n 1))))
 ) 
)
 
(defmethod rest-n ((l list) (n number)) 
  (cond ((= n 0) l )
        (t (rest-n (cdr l) (- n 1)))
 ) 
) 

;;; MELODY

(defclass melody () 
  (
    (notes   :accessor melody-notes   :initarg :notes) 
    (fitness :accessor melody-fitness :initarg :fitness) 
    (number  :accessor melody-number  :initarg :number) 
 ) 
)

(defmethod random-melody (&aux notes)
  (setf notes (random-notes))
  (make-instance 'melody 
    :notes notes
    :fitness (funcall *fitness* notes) 
    :number 0
 )
)

(defmethod new-melody ((nr number) (notes list)) 
  (make-instance 'melody 
    :notes notes
    :fitness (funcall *fitness* notes) 
    :number nr 
 )
)

(defmethod display ((i melody))
  (prin1 (melody-number i))
  (princ (filler (melody-number i)))
  (prin1 (melody-notes i))
  (princ " ")
  (prin1 (melody-fitness i))
  (princ (filler (melody-fitness i)))
  (terpri)
)

(defmethod filler ( ( n number ) ) 
  (cond
    ((< n 10) "     ")
    ((< n 100) "    ")
    ((< n 1000) "   ")
    ((< n 10000) "  ")
    ((< n 100000) " ")
 )
)

(defmethod survival-of-the-luckiest ((notes list))
  (random 100)
)

(defmethod displacements ((notes list) &aux size occurrences (note-pos 0) other-note-pos disp key value)
  (setf size (funcall (lambda (x) (* x (1+ x))) (length notes)))
  (setf occurrences (make-hash-table :test #'equal :size size))
  (loop for note in notes do
    (setf other-note-pos (1+ note-pos))
    (loop for other-note in (nthcdr other-note-pos notes) do
      (setf disp  (- other-note-pos note-pos))
      (setf key   (list note other-note disp))
      (setf value (1+ (or (nth-value 0 (gethash key occurrences)) 0)))
      (if (not (= disp 0)) (setf (gethash key occurrences) value))
      (setf other-note-pos (1+ other-note-pos))
   )
    (setf note-pos (1+ note-pos))
 )
  occurrences
)

(defmethod survival-of-displacement ((notes list) &aux melody (sum 0))
  (setf melody (displacements notes))
  (if (not (boundp '*input-displacements*)) (setf *input-displacements* (displacements *input*)))
  (loop for key being the hash-keys of *input-displacements* do
    (setf sum (+ sum (* (gethash key *input-displacements*) (or (gethash key melody) 0))))
 )
  sum
)

(defmethod fitness ((m melody))
  (funcall *fitness* (melody-notes m))
)

(setf *fitness* #'(lambda (x) (/ (survival-of-displacement x) *input-fitness*)))

(defmethod cdrn ((n integer) (l list) &aux result)
  (if (> n 0) (cdrn (1- n) (cdr l)) l)
)

;;; POPULATION

(defclass population () 
  (
    (melodies   :accessor population-melodies   :initarg :melodies) 
    (generation :accessor population-generation :initform 0) 
 ) 
) 

(defmethod size ((p population)) 
  (length (population-melodies p)) 
) 

(defmethod display ((p population)) 
  (princ "Generation ") 
  (prin1 (population-generation p)) 
  (princ " population ...") 
  (terpri)
  (dolist (i (population-melodies p)) 
    (display i) 
 ) 
) 

(defmethod initial-population (&aux melodies) 
  (setf melodies ()) 
  (dotimes (i *population-size*) 
    (push (new-melody (+ i 1) (random-notes)) melodies) 
 ) 
  (make-instance 'population :melodies (reverse melodies)) 
) 

(defmethod average ((p population) &aux melodies (sum 0)) 
  (setf melodies (population-melodies p)) 
  (dolist (i melodies)
    (setf sum (+ (melody-fitness i) sum)) 
 ) 
  (/ (* sum 1.0) *population-size*) 
)

(defmethod select-melody ((p population) &aux candidates mfi) 
  (setf candidates (select-melodies p)) 
  (setf mfi (most-fit-melody candidates))
  mfi 
) 

(defmethod select-melodies ((p population) &aux melodies candidates rn) 
  (setf melodies (population-melodies p)) 
  (setf candidates ()) 
  (dotimes (i *selection-size*) 
    (setf rn (random *population-size*)) 
    (push (nth rn melodies) candidates) 
 ) 
  candidates 
) 

(defmethod most-fit-melody ((l list) &aux max-value max-melody) 
  (setf max-value (melody-fitness (first l))) 
  (setf max-melody (first l)) 
  (dolist (i (cdr l)) 
    (cond 
      ((> (melody-fitness i) max-value) 
        (setf max-value (melody-fitness i)) 
        (setf max-melody i) 
     ) 
   ) 
 ) 
  max-melody 
) 

(defmethod maximum ((l list))
  (if (= (length l) 1) (return-from maximum (car l)))
  (if (>= (car l) (cadr l))
    (maximum (remove (cadr l) l))
    (maximum (cdr l))
 )
)

;;; MUTATE

(defmethod mutate ((i melody) &aux mutation)
  (setf mutation (mutation (melody-notes i))) 
  (make-instance 'melody 
    :number (melody-number i) 
    :notes mutation 
    :fitness (funcall *fitness* mutation) 
 ) 
) 

(defmethod maybe-mutate ((i melody)) 
  (if (<= (+ 1 (random 100)) *pc-m*) 
    (mutate i) 
    i 
 ) 
)

;;; COPY

(defmethod perform-copies ((cp population) (np population)) 
  (dotimes (i (nr-copies)) 
    (perform-one-copy cp np) 
 ) 
) 

(defmethod nr-copies () 
  (* (/ *pc-c* 100) *population-size*) 
) 

(defmethod perform-one-copy ((cp population) (np population) &aux x m mm new-i) 
  (setf m (select-melody cp)) 
  (setf mm (maybe-mutate m)) 
  (setf (melody-number mm) (+ 1 (size np))) 
  (setf new-i (new-melody (+ 1 (size np)) (melody-notes mm)))
  (setf (population-melodies np) (append (population-melodies np) (list new-i)))
  nil
) 

(defmethod empty-population ((cp population) &aux np) 
  (setf np (make-instance 'population)) 
  (setf (population-melodies np) ()) 
  (setf (population-generation np) (+ 1 (population-generation cp)))
  np 
)

;;; CROSSOVER

(defmethod perform-crossovers ((cp population) (np population)) 
  (dotimes (i (nr-crossovers)) 
    (perform-one-crossover cp np) 
 ) 
) 

(defmethod nr-crossovers () 
  (* (/ *pc-x* 100) *population-size*) 
)

(defmethod perform-one-crossover ((cp population) (np population) &aux x m mm mother father new-i)
  (setf mother (select-melody cp)) 
  (setf father (select-melody cp)) 
  (setf m (crossover mother father)) 
  (setf mm (maybe-mutate m)) 
  (setf (melody-number mm) (+ 1 (size np))) 
  (setf new-i (new-melody (+ 1 (size np)) (melody-notes mm)))
  (setf (population-melodies np) (append (population-melodies np) (list new-i)))
  nil 
) 

(defmethod crossover ((mother melody) (father melody) &aux mi fi x i) 
  (setf mi (melody-notes mother)) 
  (setf fi (melody-notes father)) 
  (setf x (crossover mi fi)) 
  (setf i (new-melody 0 x)) 
  i 
)

;;; THE GENETIC ALGORITHM

(defmethod next-generation ((cp population) &aux np) 
  (setf np (empty-population cp)) 
  (perform-copies cp np) 
  (perform-crossovers cp np)
  np
)

;;; DO IT

(defmethod make (i &aux ng last-twenty)
  (setf *random-state* (make-random-state t))
  (setf *input-displacements* (displacements *input*))
  (setf *input-fitness* (survival-of-displacement *input*))
  (dotimes (n i)
    (setf ng (if (= n 0) (initial-population) (next-generation ng)))
    (display ng)
    (terpri)
    (princ (average ng))
    (terpri)
    (display (most-fit-melody (population-melodies ng)))
    (terpri)
    (push ng last-twenty)
    (if (= (mod (length last-twenty) 20) 0) 
      (progn 
        (loop for i from (- n 19) to n do
          (setf x (nth (- n i) last-twenty))
          (format t "Population ~A least fit: ~A, average: ~A, most fit: ~A~%"
            i
            (float (loop for melody in (population-melodies x) minimize (melody-fitness melody)))
            (average x)
            (float (loop for melody in (population-melodies x) maximize (melody-fitness melody)))
         )
       )
        (setf last-twenty nil)
     )
   )
 )
  nil
)
